{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Orca.Prim.OrchMon
-- Copyright   :  (c) Stephen Tetley 2013
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Monad to build orchestra code - writer-error-state.
--
--------------------------------------------------------------------------------

module Orca.Prim.OrchMon
  (
  
    Orch
  , execOrch
  , compileOrch
  , tellGlobalStmt
  , tellInstrument



  ) where


import Orca.Prim.InstMon
import Orca.Prim.Syntax
import Orca.Prim.Utils


import Text.PrettyPrint.HughesPJ            -- pacakge: pretty

import Control.Applicative



data Wo a = Wo a !(H GlobalStmt) !(H Instrument)


newtype Orch a = Orch { getOrch :: Either ErrMsg (Wo a) }


instance Functor Orch where
  fmap f ma = Orch $ getOrch ma >>= \(Wo a vh ih) -> return $ Wo (f a) vh ih

instance Applicative Orch where
  pure a    = Orch $ return $ Wo a emptyH emptyH
  mf <*> ma = Orch $ getOrch mf >>= \(Wo f v1 i1) ->
                     getOrch ma >>= \(Wo a v2 i2) ->
                     return $ Wo (f a) (v1 `appendH` v2) (i1 `appendH` i2)



instance Monad Orch where
  return   = pure
  ma >>= k = Orch $ getOrch ma    >>= \(Wo a v1 i1) ->
                    getOrch (k a) >>= \(Wo b v2 i2) -> 
                    return $ Wo b (v1 `appendH` v2) (i1 `appendH` i2)


instance ThrowErr Orch  where
  throwErr = Orch . Left 

execOrch :: Orch () -> Either ErrMsg Orchestra 
execOrch ma = fmap sk $ getOrch ma
  where
    sk (Wo _ vh ih) = Orchestra { orch_globals = toListH vh
                                , orch_instrs  = toListH ih
                                }

compileOrch :: Orch () -> Either ErrMsg String
compileOrch = fmap (fn . ppOrch) . execOrch
  where
    fn  = renderStyle (style { lineLength = 300 })

tellGlobalStmt :: GlobalStmt -> Orch () 
tellGlobalStmt stmt = Orch $ return $ Wo () (wrapH stmt) emptyH

tellInstrument :: Instrument -> Orch ()
tellInstrument inst = Orch $ return $ Wo () emptyH (wrapH inst) 

--------------------------------------------------------------------------------


